Visual Basic Graphics Programming (2nd Edition)/Visual Basic Graphics Programming 2nd Edition.iso/OldSrc/CH7/SRC/BOXES1.FRM

Visual Basic Form | 1996-05-01 | 15.4 KB | 493 lines

VERSION 4.00
Begin VB.Form BoxesForm
   Caption         =   "Boxes"
   ClientHeight    =   3150
   ClientLeft      =   2550
   ClientTop       =   1800
   ClientWidth     =   3150
   Height          =   3840
   Left            =   2490
   LinkTopic       =   "Form1"
   ScaleHeight     =   3150
   ScaleWidth      =   3150
   Top             =   1170
   Width           =   3270
   Begin VB.HScrollBar HScrollBar
      Height          =   255
      Left            =   0
      TabIndex        =   2
      Top             =   2880
      Width           =   2895
   End
   Begin VB.VScrollBar VScrollBar
      Height          =   2895
      Left            =   2880
      TabIndex        =   1
      Top             =   0
      Width           =   255
   End
   Begin VB.PictureBox viewport
      Height          =   2880
      Left            =   0
      ScaleHeight     =   2820
      ScaleWidth      =   2820
      TabIndex        =   0
      Top             =   0
      Width           =   2880
   End
   Begin VB.Menu mnuFile
      Caption         =   "&File"
      Begin VB.Menu mnuFileExit
         Caption         =   "E&xit"
      End
   End
   Begin VB.Menu mnuScale
      Caption         =   "&Scale"
      Begin VB.Menu mnuScaleZoom
         Caption         =   "&Zoom"
         Shortcut        =   ^Z
      End
      Begin VB.Menu mnuScaleMag
         Caption         =   "Full  Scale"
         Index           =   1
         Shortcut        =   ^F
      End
      Begin VB.Menu mnuScaleMag
         Caption         =   "Magnify 1/2"
         Index           =   20
         Shortcut        =   ^{F2}
      End
      Begin VB.Menu mnuScaleMag
         Caption         =   "Magnify 1/4"
         Index           =   40
         Shortcut        =   ^{F4}
      End
   End
Attribute VB_Name = "BoxesForm"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit
Dim ThePicture As ObjPicture
' Global max and min world coordinates
' (including margins).
Dim DataXmin As Single
Dim DataXmax As Single
Dim DataYmin As Single
Dim DataYmax As Single
' Set the min and max allowed width and height.
Dim DataMinWid As Single
Dim DataMinHgt As Single
Dim DataMaxWid As Single
Dim DataMaxHgt As Single
' The aspect ratio of the viewport.
Dim VAspect As Single
' Current world window bounds.
Dim Wxmin As Single
Dim Wxmax As Single
Dim Wymin As Single
Dim Wymax As Single
' Prevent change events when we are adjusting the
' scroll bars.
Dim IgnoreSbarChange As Boolean
' Variables used for zooming.
Dim DrawingMode As Integer
Const MODE_NONE = 0
Const MODE_START_ZOOM = 1
Const MODE_ZOOMING = 2
Dim StartX As Single
Dim StartY As Single
Dim LastX As Single
Dim LastY As Single
Dim OldMode As Integer
' The object that is highlighted.
Dim highlighted As Object
' ************************************************
' End a zoom operation early. This happens if the
' user starts a zoom and the selects another menu
' item instead of doing the zoom.
' ************************************************
Sub StopZoom()
    If DrawingMode <> MODE_START_ZOOM Then Exit Sub
    DrawingMode = MODE_NONE
    Viewport.DrawMode = OldMode
    Viewport.MousePointer = vbDefault
End Sub
' ************************************************
' Change the level of magnification.
' ************************************************
Sub SetScaleFactor(fact As Single)
Dim wid As Single
Dim hgt As Single
Dim mid As Single
    fact = 1 / fact
    ' Compute the new world window size.
    wid = fact * (Wxmax - Wxmin)
    hgt = fact * (Wymax - Wymin)
    ' Center the new world window over the old.
    mid = (Wxmax + Wxmin) / 2
    Wxmin = mid - wid / 2
    Wxmax = mid + wid / 2
    mid = (Wymax + Wymin) / 2
    Wymin = mid - hgt / 2
    Wymax = mid + hgt / 2
    ' Set the new world window bounds.
    SetWorldWindow
End Sub
' ************************************************
' Adjust the world window so it is not too big,
' too small, off to one side, or of the wrong
' aspect ratio. Then map the world window to the
' viewport and force the viewport to repaint.
' ************************************************
Sub SetWorldWindow()
Dim wid As Single
Dim hgt As Single
Dim xmid As Single
Dim ymid As Single
Dim aspect As Single
    wid = Wxmax - Wxmin
    xmid = (Wxmax + Wxmin) / 2
    hgt = Wymax - Wymin
    ymid = (Wymax + Wymin) / 2

    ' Make sure we're not too big or too small.
    If wid > DataMaxWid Then
        wid = DataMaxWid
    ElseIf wid < DataMinWid Then
        wid = DataMinWid
    End If
    If hgt > DataMaxHgt Then
        hgt = DataMaxHgt
    ElseIf hgt < DataMinHgt Then
        hgt = DataMinHgt
    End If
    ' Make the aspect ratio match the
    ' viewport aspect ratio.
    aspect = hgt / wid
    If aspect > VAspect Then
        ' Too tall and thin. Make it wider.
        wid = hgt / VAspect
    Else
        ' Too short and wide. Make it taller.
        hgt = wid * VAspect
    End If
    ' Compute the new coordinates
    Wxmin = xmid - wid / 2
    Wxmax = xmid + wid / 2
    Wymin = ymid - hgt / 2
    Wymax = ymid + hgt / 2
    ' Check that we're not off to one side.
    If wid > DataMaxWid Then
        ' We're wider than the picture. Center.
        xmid = (DataXmax + DataXmin) / 2
        Wxmin = xmid - wid / 2
        Wxmax = xmid + wid / 2
    Else
        ' Else see if we're too far to one side.
        If Wxmin < DataXmin And Wxmax < DataXmax Then
            ' Adjust to the right.
            Wxmax = Wxmax + DataXmin - Wxmin
            Wxmin = DataXmin
        End If
        If Wxmax > DataXmax And Wxmin > DataXmin Then
            ' Adjust to the left.
            Wxmin = Wxmin + DataXmax - Wxmax
            Wxmax = DataXmax
        End If
    End If
    If hgt > DataMaxHgt Then
        ' We're taller than the picture. Center.
        ymid = (DataYmax + DataYmin) / 2
        Wymin = ymid - hgt / 2
        Wymax = ymid + hgt / 2
    Else
        ' See if we're too far to top or bottom.
        If Wymin < DataYmin And Wymax < DataYmax Then
            ' Adjust downward.
            Wymax = Wymax + DataYmin - Wymin
            Wymin = DataYmin
        End If
        If Wymax > DataYmax And Wymin > DataYmin Then
            ' Adjust upward.
            Wymin = Wymin + DataYmax - Wymax
            Wymax = DataYmax
        End If
    End If
    ' Map the world window to the viewport.
    Viewport.Scale (Wxmin, Wymax)-(Wxmax, Wymin)
    ' Force the viewport to repaint.
    Viewport.Refresh

    ' Reset the scroll bars.
    IgnoreSbarChange = True
    HScrollBar.Visible = (wid < DataXmax - DataXmin)
    VScrollBar.Visible = (hgt < DataYmax - DataYmin)
    ' The values of the scroll bars will be where
    ' the top/left of the world window should be.
    VScrollBar.Min = 100 * (DataYmax)
    VScrollBar.Max = 100 * (DataYmin + hgt)
    HScrollBar.Min = 100 * (DataXmin)
    HScrollBar.Max = 100 * (DataXmax - wid)
    ' SmallChange moves the world window 1/10
    ' of its width/height. Large change moves it
    ' 9/10 of its width/height.
    VScrollBar.SmallChange = 100 * (hgt / 10)
    VScrollBar.LargeChange = 100 * (9 * hgt / 10)
    HScrollBar.SmallChange = 100 * (wid / 10)
    HScrollBar.LargeChange = 100 * (9 * wid / 10)
    ' Set the current scroll bar values.
    VScrollBar.Value = 100 * Wymax
    HScrollBar.Value = 100 * Wxmin
    IgnoreSbarChange = False
End Sub
' ************************************************
' Return to the default magnification scale.
' ************************************************
Sub SetScaleFull()
    ' Reset the world window coordinates.
    Wxmin = DataXmin
    Wxmax = DataXmax
    Wymin = DataYmin
    Wymax = DataYmax
    ' Set the new world window bounds.
    SetWorldWindow
End Sub
Private Sub Form_Resize()
Dim x As Single
Dim y As Single
Dim wid As Single
Dim hgt As Single
    MakeBoxes
    ' Fit the viewport to the window.
    x = Viewport.Left
    y = Viewport.Top
    wid = ScaleWidth - 2 * x - VScrollBar.Width
    hgt = ScaleHeight - 2 * y - HScrollBar.Height
    Viewport.Move x, y, wid, hgt
    VAspect = hgt / wid
    ' Place the scroll bars next to the viewport.
    x = Viewport.Left + Viewport.Width + 10
    y = Viewport.Top
    wid = VScrollBar.Width
    hgt = Viewport.Height
    VScrollBar.Move x, y, wid, hgt
    x = Viewport.Left
    y = Viewport.Top + Viewport.Height + 10
    wid = Viewport.Width
    hgt = HScrollBar.Height
    HScrollBar.Move x, y, wid, hgt
    ' Start at full scale.
    SetScaleFull
End Sub
Sub MakeBoxes()
Const NUM_ROWS = 50
Const NUM_COLS = 50
Dim poly As ObjPolygon
Dim i As Integer
Dim j As Integer
Dim x As Single
Dim y As Single
Dim wid As Single
Dim hgt As Single
    MousePointer = vbHourglass
    DoEvents
    Set ThePicture = New ObjPicture
    y = 0
    For i = 1 To NUM_ROWS
        x = 0
        For j = 1 To NUM_COLS
            Set poly = New ObjPolygon
            ThePicture.Objects.Add poly
            poly.NumPoints = 5
            poly.SetPoint 1, x, y
            poly.SetPoint 2, x + 1, y
            poly.SetPoint 3, x + 1, y + 1
            poly.SetPoint 4, x, y + 1
            poly.SetPoint 5, x, y
            x = x + 2
        Next j
        y = y + 2
    Next i
    wid = 2 * NUM_COLS + 1
    hgt = 2 * NUM_ROWS + 1
    DataXmin = -0.1 * wid   ' 10 % margins.
    DataYmin = -0.1 * hgt
    DataXmax = 1.1 * wid
    DataYmax = 1.1 * hgt
    DataMinWid = 10
    DataMinHgt = 10
    DataMaxWid = DataXmax - DataXmin
    DataMaxHgt = DataYmax - DataYmin
    MousePointer = vbDefault
End Sub
' ************************************************
' Move the world window.
' ************************************************
Private Sub HScrollBar_Change()
    If IgnoreSbarChange Then Exit Sub
    HScrollBarChanged
End Sub
' ************************************************
' The vertical scroll bar has been moved. Adjust
' the world window.
' ************************************************
Sub VScrollBarChanged()
Dim hgt As Single
    hgt = Wymax - Wymin
    Wymax = VScrollBar.Value / 100
    Wymin = Wymax - hgt
    ' Remap the world window.
    IgnoreSbarChange = True
    SetWorldWindow
    IgnoreSbarChange = False
End Sub
' ************************************************
' The horizontal scroll bar has been moved. Adjust
' the world window.
' ************************************************
Sub HScrollBarChanged()
Dim wid As Single
    wid = Wxmax - Wxmin
    Wxmin = HScrollBar.Value / 100
    Wxmax = Wxmin + wid
    ' Remap the world window.
    IgnoreSbarChange = True
    SetWorldWindow
    IgnoreSbarChange = False
End Sub
Private Sub mnuFileExit_Click()
    StopZoom    ' If we're zooming, stop it.
    Unload Me
End Sub
' ************************************************
' Change the level of magnification.
' ************************************************
Private Sub mnuScaleMag_Click(Index As Integer)
    StopZoom    ' If we're zooming, stop it.
    If Index = 1 Then
        ' Return to full scale.
        SetScaleFull
    ElseIf Index < 10 Then
        ' Magnify by the indicated amount.
        SetScaleFactor CSng(Index)
    Else
        ' Zoom out by 1/(Index \ 10).
        SetScaleFactor 1 / (Index \ 10)
    End If
End Sub
' ************************************************
' Allow the user to select an area to zoom in on.
' ************************************************
Private Sub mnuScaleZoom_Click()
    ' Enable zooming.
    Viewport.MousePointer = vbCrosshair
    DrawingMode = MODE_START_ZOOM
End Sub
' ************************************************
' If we are zooming, start the rubberband box.
' ************************************************
Private Sub Viewport_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    Select Case DrawingMode
        Case MODE_START_ZOOM
            ' Start a zooming rubberband box.
            DrawingMode = MODE_ZOOMING

            OldMode = Viewport.DrawMode
            Viewport.DrawMode = vbInvert

            StartX = x
            StartY = y
            LastX = x
            LastY = y
            Viewport.Line (StartX, StartY)-(LastX, LastY), , B

        Case MODE_NONE
            ' Select a box.
            Dim oldcolor As Long

            ' Unhighlight the previous box.
            If Not highlighted Is Nothing Then
                highlighted.Draw Viewport
            End If

            ' Find the selected box.
            Set highlighted = ThePicture.NearestObject(x, y)
            ' Highlight the selected box.
            If Not highlighted Is Nothing Then
                oldcolor = Viewport.ForeColor
                Viewport.ForeColor = RGB(0, 255, 0)
                highlighted.Draw Viewport
                Viewport.ForeColor = oldcolor
            End If

    End Select
End Sub
' ************************************************
' If we are zooming, continue the rubberband box.
' ************************************************
Private Sub Viewport_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    If DrawingMode <> MODE_ZOOMING Then Exit Sub
    ' Erase the old box.
    Viewport.Line (StartX, StartY)-(LastX, LastY), , B
    ' Draw the new box.
    LastX = x
    LastY = y
    Viewport.Line (StartX, StartY)-(LastX, LastY), , B
End Sub
' ************************************************
' If we are zooming, finish the rubberband box.
' ************************************************
Private Sub Viewport_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
Dim wid As Single
Dim hgt As Single
Dim mid As Single
    If DrawingMode <> MODE_ZOOMING Then Exit Sub
    DrawingMode = MODE_NONE
    ' Erase the old box.
    Viewport.Line (StartX, StartY)-(LastX, LastY), , B
    LastX = x
    LastY = y
    ' We're done drawing for this rubberband box.
    Viewport.DrawMode = OldMode
    Viewport.MousePointer = vbDefault
    ' Set the new world window bounds.
    If StartX > LastX Then
        Wxmin = LastX
        Wxmax = StartX
    Else
        Wxmin = StartX
        Wxmax = LastX
    End If
    If StartY > LastY Then
        Wymin = LastY
        Wymax = StartY
    Else
        Wymin = StartY
        Wymax = LastY
    End If
    ' Set the new world window bounds.
    SetWorldWindow
End Sub
Private Sub Viewport_Paint()
Dim oldcolor As Long
    If ThePicture Is Nothing Then Exit Sub
    MousePointer = vbHourglass
    DoEvents
    ThePicture.Draw Viewport
    ' If a box is selected, highlight it.
    If Not highlighted Is Nothing Then
        oldcolor = Viewport.ForeColor
        Viewport.ForeColor = RGB(0, 255, 0)
        highlighted.Draw Viewport
        Viewport.ForeColor = oldcolor
    End If
    MousePointer = vbDefault
End Sub
' ************************************************
' Move the world window.
' ************************************************
Private Sub VScrollBar_Change()
    If IgnoreSbarChange Then Exit Sub
    VScrollBarChanged
End Sub